home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / pp.el.z / pp.el
Encoding:
Text File  |  1998-10-28  |  6.3 KB  |  180 lines
  1. ;;; pp.el --- pretty printer for Emacs Lisp
  2.  
  3. ;; Copyright (C) 1989, 1993 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Randal Schwartz <merlyn@stonehenge.com>
  6.  
  7. ;; This file is part of GNU Emacs.
  8.  
  9. ;; GNU Emacs is free software; you can redistribute it and/or modify
  10. ;; it under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; GNU Emacs is distributed in the hope that it will be useful,
  15. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17. ;; GNU General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22. ;; Boston, MA 02111-1307, USA.
  23.  
  24. ;;; Code:
  25.  
  26. (defvar pp-escape-newlines t 
  27.   "*Value of print-escape-newlines used by pp-* functions.")
  28.  
  29. (defun pp-to-string (object)
  30.   "Return a string containing the pretty-printed representation of OBJECT,
  31. any Lisp object.  Quoting characters are used when needed to make output
  32. that `read' can handle, whenever this is possible."
  33.   (save-excursion
  34.     (set-buffer (generate-new-buffer " pp-to-string"))
  35.     (unwind-protect
  36.     (progn
  37.       (lisp-mode-variables t)
  38.       (let ((print-escape-newlines pp-escape-newlines))
  39.         (prin1 object (current-buffer)))
  40.       (goto-char (point-min))
  41.       (while (not (eobp))
  42.         ;; (message "%06d" (- (point-max) (point)))
  43.         (cond
  44.          ((looking-at "\\s(\\|#\\s(")
  45.           (while (looking-at "\\s(\\|#\\s(")
  46.         (forward-char 1)))
  47.          ((and (looking-at "\\(quote[ \t]+\\)\\([^.)]\\)")
  48.            (> (match-beginning 1) 1)
  49.            (= ?\( (char-after (1- (match-beginning 1))))
  50.            ;; Make sure this is a two-element list.
  51.            (save-excursion
  52.              (goto-char (match-beginning 2))
  53.              (forward-sexp)
  54.              ;; (looking-at "[ \t]*\)")
  55.              ;; Avoid mucking with match-data; does this test work?
  56.              (char-equal ?\) (char-after (point)))))
  57.           ;; -1 gets the paren preceding the quote as well.
  58.           (delete-region (1- (match-beginning 1)) (match-end 1))
  59.           (insert "'")
  60.           (forward-sexp 1)
  61.           (if (looking-at "[ \t]*\)")
  62.           (delete-region (match-beginning 0) (match-end 0))
  63.         (error "Malformed quote"))
  64.           (backward-sexp 1))          
  65.          ((condition-case err-var
  66.           (prog1 t (down-list 1))
  67.         (error nil))
  68.           (backward-char 1)
  69.           (skip-chars-backward " \t")
  70.           (delete-region
  71.            (point)
  72.            (progn (skip-chars-forward " \t") (point)))
  73.           (if (not (char-equal ?' (char-after (1- (point)))))
  74.           (insert ?\n)))
  75.          ((condition-case err-var
  76.           (prog1 t (up-list 1))
  77.         (error nil))
  78.           (while (looking-at "\\s)")
  79.         (forward-char 1))
  80.           (skip-chars-backward " \t")
  81.           (delete-region
  82.            (point)
  83.            (progn (skip-chars-forward " \t") (point)))
  84.           (if (not (char-equal ?' (char-after (1- (point)))))
  85.           (insert ?\n)))
  86.          (t (goto-char (point-max)))))
  87.       (goto-char (point-min))
  88.       (indent-sexp)
  89.       (buffer-string))
  90.       (kill-buffer (current-buffer)))))
  91.  
  92. ;;;###autoload
  93. (defun pp (object &optional stream)
  94.   "Output the pretty-printed representation of OBJECT, any Lisp object.
  95. Quoting characters are printed when needed to make output that `read'
  96. can handle, whenever this is possible.
  97. Output stream is STREAM, or value of `standard-output' (which see)."
  98.   (princ (pp-to-string object) (or stream standard-output)))
  99.  
  100. ;;;###autoload
  101. (defun pp-eval-expression (expression)
  102.   "Evaluate EXPRESSION and pretty-print value into a new display buffer.
  103. If the pretty-printed value fits on one line, the message line is used
  104. instead.  Value is also consed on to front of variable  values 's
  105. value."
  106.   (interactive "xPp-eval: ")
  107.   (setq values (cons (eval expression) values))
  108.   (let* ((old-show-function temp-buffer-show-function)
  109.      ;; Use this function to display the buffer.
  110.      ;; This function either decides not to display it at all
  111.      ;; or displays it in the usual way.
  112.      (temp-buffer-show-function
  113.       (function
  114.        (lambda (buf)
  115.          (save-excursion
  116.            (set-buffer buf)
  117.            (goto-char (point-min))
  118.            (end-of-line 1)
  119.            (if (or (< (1+ (point)) (point-max))
  120.                (>= (- (point) (point-min)) (frame-width)))
  121.            (let ((temp-buffer-show-function old-show-function)
  122.              (old-selected (selected-window))
  123.              (window (display-buffer buf)))
  124.              (goto-char (point-min)) ; expected by some hooks ...
  125.              (make-frame-visible (window-frame window))
  126.              (unwind-protect
  127.              (progn
  128.                (select-window window)
  129.                (run-hooks 'temp-buffer-show-hook))
  130.                (select-window old-selected)))
  131.          (message "%s" (buffer-substring (point-min) (point)))
  132.          ))))))
  133.     (with-output-to-temp-buffer "*Pp Eval Output*"
  134.       (pp (car values)))
  135.     (save-excursion
  136.       (set-buffer "*Pp Eval Output*")
  137.       (emacs-lisp-mode))))
  138.  
  139. ;;;###autoload
  140. (defun pp-eval-last-sexp (arg)
  141.   "Run `pp-eval-expression' on sexp before point (which see).
  142. With argument, pretty-print output into current buffer.
  143. Ignores leading comment characters."
  144.   (interactive "P")
  145.   (let ((stab (syntax-table)) (pt (point)) start exp)
  146.     (set-syntax-table emacs-lisp-mode-syntax-table)
  147.     (save-excursion
  148.       (forward-sexp -1)
  149.       ;; If first line is commented, ignore all leading comments:
  150.       (if (save-excursion (beginning-of-line) (looking-at "[ \t]*;"))
  151.       (progn
  152.         (setq exp (buffer-substring (point) pt))
  153.         (while (string-match "\n[ \t]*;+" exp start)
  154.           (setq start (1+ (match-beginning 0))
  155.             exp (concat (substring exp 0 start)
  156.                 (substring exp (match-end 0)))))
  157.         (setq exp (read exp)))
  158.     (setq exp (read (current-buffer)))))
  159.     (set-syntax-table stab)
  160.     (if arg
  161.     (insert (pp-to-string (eval exp)))
  162.       (pp-eval-expression exp))))
  163.  
  164. ;;; Test cases for quote
  165. ;; (pp-eval-expression ''(quote quote))
  166. ;; (pp-eval-expression ''((quote a) (quote b)))
  167. ;; (pp-eval-expression ''('a 'b))    ; same as above
  168. ;; (pp-eval-expression ''((quote (quote quote)) (quote quote)))
  169. ;; These do not satisfy the quote test.
  170. ;; (pp-eval-expression ''quote)
  171. ;; (pp-eval-expression ''(quote))
  172. ;; (pp-eval-expression ''(quote . quote))
  173. ;; (pp-eval-expression ''(quote a b))
  174. ;; (pp-eval-expression ''(quotefoo))
  175. ;; (pp-eval-expression ''(a b))
  176.  
  177. (provide 'pp)                ; so (require 'pp) works
  178.  
  179. ;;; pp.el ends here.
  180.